;;; -*- lisp -*- 
(in-package :yadd)

#.(enable-uri-template-syntax)

(defparameter *loading-directory*
  (merge-pathnames #P"Desktop/dsv/" (user-homedir-pathname)))

(defclass job () 
  ((address-regex :reader job-address-regex :initform nil :allocation :class)
   (link-regex    :reader job-link-regex    :initform nil :allocation :class)
   (hosts         :reader job-hosts         :initform nil :allocation :class)
   (address :reader   job-address :initarg :address :type string)
   (link    :accessor job-link    :initarg :link    :type string)
   (name    :accessor job-name    :initarg :name    :type string)
   (length  :accessor job-length  :initarg :length  :type integer)
   ;;(file :reader job-file :initarg :file :initform nil)))
   ))

(defmacro defjob (name &key
                  ((:is is) 'job is-supplied?)
                  ((:address address) nil address-supplied?)
                  ((:link link) nil link-supplied?)
                  ((:hosts hosts) nil hosts-supplied?))
  (let ((the-hosts (gensym)))
    `(progn (defclass ,name (,is)
              ((address-regex :initform (when ,address-supplied? (re ,address)))
               (link-regex :initform (when ,link-supplied? (re ,link)))
               (hosts :initform (when ,hosts-supplied?
                                  (let ((,the-hosts ,hosts))
                                    (if (listp ,the-hosts)
                                        (loop for host in ,the-hosts collect host)
                                        (list ,the-hosts))))))))))

(defmethod print-object ((job job) stream)
  (print-unreadable-object (job stream :type t :identity t)
    (apply (curry #'format stream)
           (with-slots (name address) job
             (cond ((slot-boundp job 'name) (list "~a" name))
                   ((slot-boundp job 'address) (list "At ~a" address))
                   (t (list "With no name/address")))))))

(defun address-regex-slot (job-class)
  (funcall (sb-mop:slot-definition-initfunction
            (first (sb-mop:class-slots job-class)))))

(defjob cod.ru-job)
(defjob data.cod.ru-job :is cod.ru-job
        :address "http://data.cod.ru/\\d{5}"
        :link "http://files.data.cod.ru/.+")
(defjob dsv.data.cod.ru-job :is cod.ru-job
        :address "http://dsv.data.cod.ru/\\d{6}"
        :link "http://files[23]?.dsv.data.cod.ru/.+"
        :hosts  (list "files3?.dsv.data.cod.ru" "files2.dsv.data.cod.ru"))
(defjob dsvload.net-job :address "http://dsvload.net/ftpupload/.+")
(defjob 77.35.112.8?-job :address "(http|ftp)://77.35.112.8[234]/.+")

(finalize-subclasses-inheritance 'job)

(defun make-job (address-line)
  "Parse address line and return job."
  (when (stringp address-line)
    (some (lambda (job) (when-let ((regex (address-regex-slot job))
                              (address (scan-to-strings regex address-line)))
                     (make-instance job :address address)))
          (subclasses 'job))))

(defun make-jobs (&key ((:from-file file)
                        (merge-pathnames #P".jobs" *loading-directory*)
                        file-supplied?)
                  ((:from-list list) nil list-supplied?))
  (cond ((and (not list-supplied?) (not file-supplied?))
         (make-jobs :from-file file))
        ((and list-supplied? file-supplied?)
         (append (make-jobs :from-file file)
                 (make-jobs :from-list list)))
        (file-supplied? (make-jobs :from-list (read-lines file)))
        (list-supplied? (remove nil (mapcar #'make-job list)))))

(defmethod job-host ((job job))
  ;; возможно нужно разделение по схемам на одном хосте
  (when-let ((host (uri-host (job-link job))))
    (if-let ((hosts (job-hosts job)))
      (some (lambda (hosts-regex) (when (scan hosts-regex host) hosts-regex))
            hosts)
      host)))

(defmethod job-length ((job job)) ;; need testing and dispatch on protocol
  (with-slots (length) job
    (if (boundp 'length) length
        (when-let ((new-length
                    (header-value :content-length
                                  (header (encode-uri (job-link job))))))
          (setf length (parse-integer new-length))))))

(defmethod job-file ((job job))
  (with-accessors ((name job-name)) job
    (when name (merge-pathnames (make-pathname :name name) *loading-directory*))))

(defmethod job-file-length ((job job))
  (with-accessors ((file job-file)) job
    (when file
      (if (probe-file file)
          (with-open-file (file-stream file) (file-length file-stream))
          0))))

(defmethod job-link ((job (eql nil))) nil)

(defmethod job-link ((job job)) (job-address job))

(defmethod job-link ((job cod.ru-job))
  (labels ((get-attr (attr elem)
             (when (consp (car elem))
               (iter (for x on (cdar elem) by #'cddr)
                     (finding (second x) such-that (eq attr (first x))))))
           (callback (link)
             (list (cons :a #'(lambda (attributes)
                                (let ((ref (get-attr :href attributes)))
                                    (when (scan (job-link-regex job) ref)
                                      (format link "~a" ref))))))))
    (with-slots (link address) job
      (if (boundp 'link) link
          (handler-case
              (let ((new-link
                     (with-output-to-string (new-link)
                       (parse-html (http-request address)
                                   :callback-only t
                                   :callbacks (funcall #'callback new-link)))))
                (setf link (not-empty new-link)))
            ;; (drakma::drakma-simple-error () nil)))))
            (usocket:timeout-error () link)))))) ; Returns unbound slot here!

(defmethod job-name ((job (eql nil))) nil)

(defmethod job-name ((job job))
  (with-slots (name) job
    (if (boundp 'name) name 
        (setf name (uri-file (job-link job))))))

(defmethod job-name ((job cod.ru-job))
  (labels ((utf-char (str) (code-char (parse-integer str :radix 16)))
           (decode-utf-string (utf-string)
             (with-output-to-string (out)
               (do-register-groups (NIL (#'utf-char char) string)
                   ("(\\u([\\da-f]{4}))|([\\w\\s\\.]+)" utf-string)
                 (princ (or char string) out)))))
    (with-slots (name) job
      (with-accessors ((link job-link)) job
        (if (boundp 'name) name
            (let ((new-name
                   (and link
                        (register-groups-bind (encoded-name)
                            ("\[\"[\\da-f]+\",\"?\\d+\"?,\"(.*)\",\""
                             (base64-string-to-string
                              (substitute #\Space #\% (uri-query link))))
                          (decode-utf-string encoded-name)))))
              (setf name (not-empty new-name))))))))
  
(defmethod download :around ((job job))
  (with-accessors ((link job-link) (name job-name) (address job-address)
                   (file-length job-file-length) (length job-length))  job
    (cond ((empty? link) (not (logg "NO FILE on address > ~a~%" address)))
          ((= file-length length) (not (logg "ALREADY DONE > ~a~%" name)))
          (:else (progn (logg "START > ~a~%" name)
                        (if (call-next-method)
                            (not (logg "END > ~a~%" name))
                            (logg "FAILED > ~a~%" name)))))))

(defmethod download ((job job))
  (with-accessors ((link job-link) (name job-name)
                   (file job-file) (file-length job-file-length)
                   (length job-length)) job
    (iter (repeat 3) (when (= file-length length) (leave t))
          (handler-case 
              (with-open-file
                  (local-file file :direction :output
                              :element-type '(unsigned-byte 8)
                              :if-exists :append :if-does-not-exist :create)
                (with-open-stream
                    (remote-file (http-request (encode-uri link)
                                               :additional-headers
                                               (list (range-header :start file-length))
                                               :want-stream t :force-binary t))
                  (transfer-bytes :from-stream remote-file :to-stream local-file)))
            ((or drakma::drakma-simple-error usocket:timeout-error)
                () (next-iteration))))))

(defmethod download ((job (eql nil))) T)

(defmethod download ((jobs cons))
  (download (remove-if #'download jobs)))

(defun multithreaded-download (jobs)
  (iter (for (host . jobs-on-host) in
             (remove nil (group-by #'job-host jobs :test #'string=) :key #'first))
        (muproc-spawn (make-symbol (str "DOWNLOAD " host))
                      #'download (list jobs-on-host)
                      :errorstream *trace-output*)))